home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / lsp / numlib.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1987-06-04  |  5.5 KB  |  186 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;    numlib.lsp
  6. ;;;;
  7. ;;;;                           number routines
  8.  
  9.  
  10. (in-package 'lisp)
  11. (export
  12.  '(isqrt abs phase signum cis asin acos sinh cosh tanh
  13.    asinh acosh atanh
  14.    rational rationalize
  15.    ffloor fround ftruncate fceiling
  16.    lognand lognor logandc1 logandc2 logorc1 logorc2
  17.    lognot logtest
  18.    byte byte-size byte-position
  19.    ldb ldb-test mask-field dpb deposit-field
  20.    ))
  21.  
  22.  
  23. (in-package 'system)
  24.  
  25.  
  26. (proclaim '(optimize (safety 2) (space 3)))
  27.  
  28.  
  29. (defconstant imag-one #C(0.0s0 1.0s0))
  30.  
  31.  
  32. (defun isqrt (i)
  33.        (unless (and (integerp i) (>= i 0))
  34.                (error "~S is not a non-negative integer." i))
  35.        (if (zerop i)
  36.            0
  37.            (let ((n (integer-length i)))
  38.                 (do ((x (ash 1 (ceiling n 2)))
  39.                      (y))
  40.                     (nil)
  41.                     (setq y (floor i x))
  42.                     (when (<= x y)
  43.                           (return x))
  44.                     (setq x (floor (+ x y) 2))))))
  45.  
  46. (defun abs (x)
  47.        (if (complexp x)
  48.            (sqrt (+ (* (realpart x) (realpart x))
  49.                     (* (imagpart x) (imagpart x))))
  50.            (if (minusp x)
  51.                (- x)
  52.                x)))
  53.  
  54. (defun phase (x)
  55.        (atan (imagpart x) (realpart x)))
  56.  
  57. (defun signum (x) (if (zerop x) x (/ x (abs x))))
  58.  
  59. (defun cis (x) (exp (* imag-one x)))
  60.  
  61. (defun asin (x)
  62.        (let ((c (- (* imag-one
  63.                       (log (+ (* imag-one x)
  64.                               (sqrt (- 1.0s0 (* x x)))))))))
  65.             (if (and (not (complexp x)) (zerop (imagpart c)))
  66.                 (realpart c)
  67.                 c)))
  68.  
  69. (defun acos (x)
  70.        (let ((c (- (* imag-one
  71.                       (log (+ x (* imag-one
  72.                                    (sqrt (- 1.0s0 (* x x))))))))))
  73.             (if (and (not (complexp x)) (zerop (imagpart c)))
  74.                 (realpart c)
  75.                 c)))
  76.  
  77. (defun sinh (x) (/ (- (exp x) (exp (- x))) 2.0s0))
  78. (defun cosh (x) (/ (+ (exp x) (exp (- x))) 2.0s0))
  79. (defun tanh (x) (/ (sinh x) (cosh x)))
  80.  
  81. (defun asinh (x) (log (+ x (sqrt (+ 1.0s0 (* x x))))))
  82. (defun acosh (x)
  83.        (log (+ x
  84.                (* (1+ x)
  85.                     (sqrt (/ (1- x) (1+ x)))))))
  86. (defun atanh (x)
  87.        (when (or (= x 1.0s0) (= x -1.0s0))
  88.              (error "The argument, ~s, is a logarithmic singularity.~
  89.                     ~%Don't be foolish, GLS."
  90.                     x))
  91.        (log (/ (1+ x) (sqrt (- 1.0s0 (* x x))))))
  92.  
  93.  
  94. (defun rational (x)
  95.        (multiple-value-bind (i e s) (integer-decode-float x)
  96.         (if (>= s 0)
  97.             (* i (expt (float-radix x) e))
  98.             (- (* i (expt (float-radix x) e))))))
  99.  
  100.  
  101. ;;; Rationalize originally by Skef Wholey.
  102. ;;; Obtained from Daniel L. Weinreb.
  103. (defun rationalize (x)
  104.   (typecase x
  105.     (rational x)
  106.     (short-float (rationalize-float x short-float-epsilon))
  107.     (long-float (rationalize-float x long-float-epsilon))
  108.     (otherwise (error "~S is neither rational nor float." x))))
  109.  
  110. (defun rationalize-float (x eps)
  111.   (cond ((minusp x) (- (rationalize (- x))))
  112.         ((zerop x) 0)
  113.         (t (let ((y ())
  114.                  (a ()))
  115.              (do ((xx x (setq y (/ 1.0s0
  116.                                    (- xx (float a x)))))
  117.                   (num (setq a (truncate x))
  118.                        (+ (* (setq a (truncate y)) num) onum))
  119.                   (den 1 (+ (* a den) oden))
  120.                   (onum 1 num)
  121.                   (oden 0 den))
  122.                  ((and (not (zerop den))
  123.                        (not (> (abs (/ (- x (/ (float num x)
  124.                                                (float den x)))
  125.                                        x))
  126.                                eps)))
  127.                   (/ num den)))))))
  128.  
  129.  
  130. (defun ffloor (x &optional (y 1.0s0))
  131.        (multiple-value-bind (i r) (floor (float x) (float y))
  132.         (values (float i r) r)))
  133.  
  134. (defun fceiling (x &optional (y 1.0s0))
  135.        (multiple-value-bind (i r) (ceiling (float x) (float y))
  136.         (values (float i r) r)))
  137.  
  138. (defun ftruncate (x &optional (y 1.0s0))
  139.        (multiple-value-bind (i r) (truncate (float x) (float y))
  140.         (values (float i r) r)))
  141.  
  142. (defun fround (x &optional (y 1.0s0))
  143.        (multiple-value-bind (i r) (round (float x) (float y))
  144.         (values (float i r) r)))
  145.  
  146.  
  147. (defun lognand (x y) (boole boole-nand x y))
  148. (defun lognor (x y) (boole boole-nor x y))
  149. (defun logandc1 (x y) (boole boole-andc1 x y))
  150. (defun logandc2 (x y) (boole boole-andc2 x y))
  151. (defun logorc1 (x y) (boole boole-orc1 x y))
  152. (defun logorc2 (x y) (boole boole-orc2 x y))
  153.  
  154. (defun lognot (x) (logxor -1 x))
  155. (defun logtest (x y) (not (zerop (logand x y))))
  156.  
  157.  
  158. (defun byte (size position)
  159.   (cons size position))
  160.  
  161. (defun byte-size (bytespec)
  162.   (car bytespec))
  163.  
  164. (defun byte-position (bytespec)
  165.   (cdr bytespec))
  166.  
  167. (defun ldb (bytespec integer)
  168.   (logandc2 (ash integer (- (byte-position bytespec)))
  169.             (- (ash 1 (byte-size bytespec)))))
  170.  
  171. (defun ldb-test (bytespec integer)
  172.   (not (zerop (ldb bytespec integer))))
  173.  
  174. (defun mask-field (bytespec integer)
  175.   (ash (ldb bytespec integer) (byte-position bytespec)))
  176.  
  177. (defun dpb (newbyte bytespec integer)
  178.   (logxor integer
  179.           (mask-field bytespec integer)
  180.           (ash (logandc2 newbyte
  181.                          (- (ash 1 (byte-size bytespec))))
  182.                (byte-position bytespec))))
  183.  
  184. (defun deposit-field (newbyte bytespec integer)
  185.   (dpb (ash newbyte (- (byte-position bytespec))) bytespec integer))
  186.